home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / sptmbr11.lha / clx / exclcmac.lisp < prev    next >
Text File  |  1991-06-10  |  8KB  |  261 lines
  1. ;;; -*- Mode: common-lisp; Package: xlib; Base: 10; Lowercase: Yes -*-
  2. ;;;
  3. ;;; CLX -- exclcmac.cl
  4. ;;;           This file provides for inline expansion of some functions.
  5. ;;;
  6. ;;; Copyright (c) 1989 Franz Inc, Berkeley, Ca.
  7. ;;;
  8. ;;; Permission is granted to any individual or institution to use, copy,
  9. ;;; modify, and distribute this software, provided that this complete
  10. ;;; copyright and permission notice is maintained, intact, in all copies and
  11. ;;; supporting documentation.
  12. ;;;
  13. ;;; Franz Incorporated provides this software "as is" without
  14. ;;; express or implied warranty.
  15. ;;;
  16.  
  17. (in-package :xlib)
  18.  
  19. ;;
  20. ;; Type predicates
  21. ;;
  22. (excl:defcmacro card8p (x)
  23.   (let ((xx (gensym)))
  24.     `(let ((,xx ,x))
  25.        (declare (optimize (speed 3) (safety 0))
  26.         (fixnum ,xx))
  27.        (and (excl:fixnump ,xx) (> #.(expt 2 8) ,xx) (>= ,xx 0)))))
  28.  
  29. (excl:defcmacro card16p (x)
  30.   (let ((xx (gensym)))
  31.     `(let ((,xx ,x))
  32.        (declare (optimize (speed 3) (safety 0))
  33.         (fixnum ,xx))
  34.        (and (excl:fixnump ,xx) (> #.(expt 2 16) ,xx) (>= ,xx 0)))))
  35.  
  36. (excl:defcmacro int8p (x)
  37.   (let ((xx (gensym)))
  38.     `(let ((,xx ,x))
  39.        (declare (optimize (speed 3) (safety 0))
  40.         (fixnum ,xx))
  41.        (and (excl:fixnump ,xx) (> #.(expt 2 7) ,xx) (>= ,xx #.(expt -2 7))))))
  42.  
  43. (excl:defcmacro int16p (x)
  44.   (let ((xx (gensym)))
  45.     `(let ((,xx ,x))
  46.        (declare (optimize (speed 3) (safety 0))
  47.         (fixnum ,xx))
  48.        (and (excl:fixnump ,xx) (> #.(expt 2 15) ,xx) (>= ,xx #.(expt -2 15))))))
  49.  
  50. ;; Card29p, card32p, int32p are too large to expand inline
  51.  
  52.  
  53. ;;
  54. ;; Type transformers
  55. ;;
  56. (excl:defcmacro card8->int8 (x)
  57.   (let ((xx (gensym)))
  58.     `(let ((,xx ,x))
  59.        ,(declare-bufmac)
  60.        (declare (type card8 ,xx))
  61.        (the int8 (if (logbitp 7 ,xx)
  62.              (the int8 (- ,xx #x100))
  63.            ,xx)))))
  64. (excl:defcmacro int8->card8 (x)
  65.   `(locally ,(declare-bufmac)
  66.      (the card8 (ldb (byte 8 0) (the int8 ,x)))))
  67.  
  68. (excl:defcmacro card16->int16 (x)
  69.   (let ((xx (gensym)))
  70.     `(let ((,xx ,x))
  71.        ,(declare-bufmac)
  72.        (declare (type card16 ,xx))
  73.        (the int16 (if (logbitp 15 ,xx)
  74.               (the int16 (- ,xx #x10000))
  75.             ,xx)))))
  76.  
  77. (excl:defcmacro int16->card16 (x)
  78.   `(locally ,(declare-bufmac)
  79.      (the card16 (ldb (byte 16 0) (the int16 ,x)))))
  80.  
  81. (excl:defcmacro card32->int32 (x)
  82.   (let ((xx (gensym)))
  83.     `(let ((,xx ,x))
  84.        ,(declare-bufmac)
  85.        (declare (type card32 ,xx))
  86.        (the int32 (if (logbitp 31 ,xx)
  87.               (the int32 (- ,xx #x100000000))
  88.             ,xx)))))
  89.  
  90. (excl:defcmacro int32->card32 (x)
  91.   `(locally ,(declare-bufmac)
  92.      (the card32 (ldb (byte 32 0) (the int32 ,x)))))
  93.  
  94. (excl:defcmacro char->card8 (char)
  95.   `(locally ,(declare-bufmac)
  96.      (the card8 (char-code (the string-char ,char)))))
  97.  
  98. (excl:defcmacro card8->char (card8)
  99.   `(locally ,(declare-bufmac)
  100.      (the string-char (code-char (the card8 ,card8)))))
  101.  
  102.  
  103. ;;
  104. ;; Array accessors and setters
  105. ;;
  106. (excl:defcmacro aref-card8 (a i)
  107.   `(locally ,(declare-bufmac)
  108.      (the card8 (sys:memref (the buffer-bytes ,a)
  109.                 #.(comp::mdparam 'comp::md-svector-data0-adj)
  110.                 (the array-index ,i)
  111.                 :unsigned-byte))))
  112.   
  113. (excl:defcmacro aset-card8 (v a i)
  114.   `(locally ,(declare-bufmac)
  115.      (setf (sys:memref (the buffer-bytes ,a)
  116.                #.(comp::mdparam 'comp::md-svector-data0-adj)
  117.                (the array-index ,i)
  118.                :unsigned-byte)
  119.        (the card8 ,v))))
  120.   
  121. (excl:defcmacro aref-int8 (a i)
  122.   `(locally ,(declare-bufmac)
  123.      (the int8 (sys:memref (the buffer-bytes ,a)
  124.                #.(comp::mdparam 'comp::md-svector-data0-adj)
  125.                (the array-index ,i)
  126.                :signed-byte))))
  127.   
  128. (excl:defcmacro aset-int8 (v a i)
  129.   `(locally ,(declare-bufmac)
  130.      (setf (sys:memref (the buffer-bytes ,a)
  131.                #.(comp::mdparam 'comp::md-svector-data0-adj)
  132.                (the array-index ,i)
  133.                :signed-byte)
  134.        (the int8 ,v))))
  135.  
  136. (excl:defcmacro aref-card16 (a i)
  137.   `(locally ,(declare-bufmac)
  138.      (the card16 (sys:memref (the buffer-bytes ,a)
  139.                  #.(comp::mdparam 'comp::md-svector-data0-adj)
  140.                  (the array-index ,i)
  141.                  :unsigned-word))))
  142.   
  143. (excl:defcmacro aset-card16 (v a i)
  144.   `(locally ,(declare-bufmac)
  145.      (setf (sys:memref (the buffer-bytes ,a)
  146.                #.(comp::mdparam 'comp::md-svector-data0-adj)
  147.                (the array-index ,i)
  148.                :unsigned-word)
  149.        (the card16 ,v))))
  150.   
  151. (excl:defcmacro aref-int16 (a i)
  152.   `(locally ,(declare-bufmac)
  153.      (the int16 (sys:memref (the buffer-bytes ,a)
  154.                 #.(comp::mdparam 'comp::md-svector-data0-adj)
  155.                 (the array-index ,i)
  156.                 :signed-word))))
  157.   
  158. (excl:defcmacro aset-int16 (v a i)
  159.   `(locally ,(declare-bufmac)
  160.      (setf (sys:memref (the buffer-bytes ,a)
  161.                #.(comp::mdparam 'comp::md-svector-data0-adj)
  162.                (the array-index ,i)
  163.                :signed-word)
  164.        (the int16 ,v))))
  165.   
  166. (excl:defcmacro aref-card32 (a i)
  167.   `(locally ,(declare-bufmac)
  168.      (the card32 (sys:memref (the buffer-bytes ,a)
  169.                  #.(comp::mdparam 'comp::md-svector-data0-adj)
  170.                  (the array-index ,i)
  171.                  :unsigned-long))))
  172.     
  173. (excl:defcmacro aset-card32 (v a i)
  174.   `(locally ,(declare-bufmac)
  175.      (setf (sys:memref (the buffer-bytes ,a)
  176.                #.(comp::mdparam 'comp::md-svector-data0-adj)
  177.                (the array-index ,i)
  178.                :unsigned-long)
  179.        (the card32 ,v))))
  180.  
  181. (excl:defcmacro aref-int32 (a i)
  182.   `(locally ,(declare-bufmac)
  183.      (the int32 (sys:memref (the buffer-bytes ,a)
  184.                 #.(comp::mdparam 'comp::md-svector-data0-adj)
  185.                 (the array-index ,i)
  186.                 :signed-long))))
  187.     
  188. (excl:defcmacro aset-int32 (v a i)
  189.   `(locally ,(declare-bufmac)
  190.      (setf (sys:memref (the buffer-bytes ,a)
  191.                #.(comp::mdparam 'comp::md-svector-data0-adj)
  192.                (the array-index ,i)
  193.                :signed-long)
  194.        (the int32 ,v))))
  195.  
  196. (excl:defcmacro aref-card29 (a i)
  197.   ;; Don't need to mask bits here since X protocol guarantees top bits zero
  198.   `(locally ,(declare-bufmac)
  199.      (the card29 (sys:memref (the buffer-bytes ,a)
  200.                  #.(comp::mdparam 'comp::md-svector-data0-adj)
  201.                  (the array-index ,i)
  202.                  :unsigned-long))))
  203.  
  204. (excl:defcmacro aset-card29 (v a i)
  205.   ;; I also assume here Lisp is passing a number that fits in 29 bits.
  206.   `(locally ,(declare-bufmac)
  207.      (setf (sys:memref (the buffer-bytes ,a)
  208.                #.(comp::mdparam 'comp::md-svector-data0-adj)
  209.                (the array-index ,i)
  210.                :unsigned-long)
  211.        (the card29 ,v))))
  212.  
  213. ;;
  214. ;; Font accessors
  215. ;;
  216. (excl:defcmacro font-id (font)
  217.   ;; Get font-id, opening font if needed
  218.   (let ((f (gensym)))
  219.     `(let ((,f ,font))
  220.        (or (font-id-internal ,f)
  221.        (open-font-internal ,f)))))
  222.  
  223. (excl:defcmacro font-font-info (font)
  224.   (let ((f (gensym)))
  225.     `(let ((,f ,font))
  226.        (or (font-font-info-internal ,f)
  227.        (query-font ,f)))))
  228.  
  229. (excl:defcmacro font-char-infos (font)
  230.   (let ((f (gensym)))
  231.     `(let ((,f ,font))
  232.        (or (font-char-infos-internal ,f)
  233.        (progn (query-font ,f)
  234.           (font-char-infos-internal ,f))))))
  235.  
  236.  
  237. ;;
  238. ;; Miscellaneous
  239. ;;
  240. (excl:defcmacro current-process ()
  241.   `(the (or mp::process null) (and mp::*scheduler-stack-group*
  242.                   mp::*current-process*)))
  243.  
  244. (excl:defcmacro process-wakeup (process)
  245.   (let ((proc (gensym)))
  246.     `(let ((.pw-curproc. mp::*current-process*)
  247.        (,proc ,process))
  248.        (when (and .pw-curproc. ,proc)
  249.      (if (> (mp::process-priority ,proc)
  250.         (mp::process-priority .pw-curproc.))
  251.          (mp::process-allow-schedule ,proc))))))
  252.  
  253. (excl:defcmacro buffer-new-request-number (buffer)
  254.   (let ((buf (gensym)))
  255.     `(let ((,buf ,buffer))
  256.        (declare (type buffer ,buf))
  257.        (setf (buffer-request-number ,buf)
  258.      (ldb (byte 16 0) (1+ (buffer-request-number ,buf)))))))
  259.  
  260.  
  261.